perm filename LINEW.F4[RST,LCS] blob
sn#085797 filedate 1974-02-02 generic text, type T, neo UTF8
00100 SUBROUTINE LINES(I)
00110
00200 COMMON/FU/FUJ(512),JJX,RDIV,ADML/MEDGE/MC,MD,RMC,MMD
00300 COMMON/DRW/JDRW(2000)
00400 EQUIVALENCE(KNT,JDRW(1))
00500 COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
00555 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
00610 DATA IFLIP/-1/,RDIV/.5/,FUJ(1)/99./
00615 CALL SWITCH
00617 C REVERSE OR INVERT (IN 'SWITCH') HAPPEN BEFORE DISTORTION OR ROTATE.
00620 IF(FUJ(1).EQ.99)GO TO 31
00625 RX=JA*RMC+1
00630 IF(RX.GT.512.)RX=512.
00636 IF(ADML.GE.0)GO TO 32
00637 JB=JB+MMD*FUJ(IFIX(RX))
00638 C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
00639 GO TO 31
00650 32 NY=JB-MMD
00680 JB=MMD+NY*FUJ(IFIX(RX))
00705 31 IF(ROT.LE.1)GO TO 9
00710 RX=JA
00715 RY=JB
00720 AX=ATAN2(RY,RX)*57.29578
00725 HYP=SQRT(RX**2+RY**2)
00730 RT=ROT+AX
00735 JA=HYP*COSD(RT)
00740 JB=HYP*SIND(RT)
00745 GO TO 10
00800 9 IF(ROT.GT.0)CALL EXCH(JA,JB)
00900 10 JA=JA+JX
01000 JB=JB+JY
01100 C IF ROT.GE.0 ROTATE 90 DEG. TO LEFT
01200 M=JA
01300 N=JB
01400 IF(PLT)GO TO 1
01500 6 M=M-JAR
01600 N=N-JBR
01700 CC2 TYPE 20,M,N,JX,JY
01800 20 FORMAT(4I6)
01900 IF(I.EQ.3)GO TO 3
02000 CALL RVECT(M,N)
02100 5 JAR=JA
02200 JBR=JB
02300 RETURN
02400 3 CALL RIVECT(M,N)
02500 GO TO 5
02600
02700 CC1 TYPE 20,M,N,JX,JY
02800 1 IF(PLT.EQ.-2)GO TO 4
02900 CALL PLOT(M,N,I)
03000 RETURN
03050 4 IFLIP=-IFLIP
03060 IF(I.EQ.3)GO TO 7
03100 IF(KNT.GE.200.OR.IFLIP)RETURN
03110 GO TO 70
03155 7 IF(JDRW(KNT).GT.100000000)GO TO 71
03200 70 KNT=KNT+1
03220 71 M=M/8
03240 N=N/8
03410 IF(M.NE.KM)GO TO 56
03420 IF(IABS(N-KN).GT.1)GO TO 55
03425 IF(N.EQ.KN)GO TO 59
03430 57 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03440 GO TO 58
03450 56 IF(N.NE.KN)GO TO 55
03460 IF(IABS(M-KM).LE.1)GO TO 57
03500 GO TO 55
03600 59 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03700 RETURN
03710 55 IF(I.NE.3)GO TO 11
03711 KM=10000
03712 GO TO 8
03715 11 IF(M-KM.NE.LM.OR.N-KN.NE.LN)GO TO 8
03717 IF(JDRW(KNT-1).LT.100000000)KNT=KNT-1
03720 8 LN=N-KN
03725 LM=M-KM
03800 KM=M
03900 KN=N
03910 58 M=(M-50)*10000
03915 N=N-50
04000 IF(M)M=10000000-M
04100 IF(N)N=1000-N
04200 IF(I.EQ.3)M=M+100000000
04300 JDRW(KNT)=M+N
04350 IF(JDRW(KNT).EQ.0)KNT=KNT-1
04400 END
04500
04600 SUBROUTINE EXCH(J,K)
04700 I=J
04800 J=K
04900 K=I
05000 END
05100
05200 SUBROUTINE JZERO
05300 COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
05400 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
05500 JAR=0
05600 JBR=0
05700 END
05800
05900 SUBROUTINE DSTORT(JPL)
06000 COMMON/MEDGE/MC,MD,RMC,MMD/FU/FUJ(512),JJX,RDIV,ADML
06100 MMD=(MD/JPL)*RDIV
06150 IF(ADML)MMD=RDIV*(MD/JPL)
06151 C 'CENTR' IS MULT FOR ADDING! (CENTR 102 = MULT THE FUNC BY 2 AND ADD)
06200 RMC=MC
06300 RMC=511./(RMC/JPL)
06400 END
06500
06600 SUBROUTINE INVIS(MA,MB,MC,MD,N)
06700 DIMENSION LL(100)
06800 COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
06900 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
07000 CALL JZERO
07100 NA=MA/3
07200 NB=MB/3
07300 NC=MC/3
07400 ND=MD/3
07500 IF(N.EQ.0)N=-1
07600 IF(N)CALL DPYSET(2,LL,100)
07700 N=1
07800 CALL JZERO
07900 CALL DPYBRT(2)
08000 1 CALL AIVECT(-380,-200)
08100 JA=NA
08200 JB=NC
08300 CALL LINES(3)
08400 JB=NC
08500 JA=NB
08600 CALL LINES(2)
08700 JB=ND
08800 JA=NB
08900 CALL LINES(2)
09000 JA=NA
09100 JB=ND
09200 CALL LINES(2)
09300 JA=NA
09400 JB=NC
09500 CALL LINES(2)
09600 CALL JZERO
09700 6683 CALL DPYOUT(2)
09800 END
09900
09950 SUBROUTINE SWITCH
10000 COMMON/PLT/JX,JY,JPL,PLT,REV,RINV,ROT,RLR,RUD,CONST,E
10100 1 ,JREV,JINV,KA,KB,KC,KD,RTO,JA,JB,JAR,JBR,A,IA,IB,IC,ID
10200 IF(REV.NE.0)JA=JREV-JA
10300 IF(RINV.NE.0)JB=JINV-JB
10400 END
10500
10600 SUBROUTINE DPFUN(JFU)
10700 COMMON/FU/FUJ(512),JJX,RDIV,ADML/DRW/LIST(2000)
19000 13 IF(JFU.NE.' ')GO TO 19
19100 TYPE 14
19200 14 FORMAT(' FUNC FILE NAME? ',$)
19300 15 FORMAT(8F)
19350 83 FORMAT(A5)
19400 ACCEPT 83,JFU
19500 IF(JFU.NE.' ')GO TO 19
19600 FUJ(1)=99.
19700 C A BLANK DELETES FUNC ACTION.
19800 RETURN
19900 19 REWIND 1
20000 CALL IFILE(1,JFU)
20100 DO 17 K=1,3
20200 17 READ(1,18)A,B,B
20300 18 FORMAT(3A5)
20400 16 READ(1,15)A,B
20500 IF(B.NE.520.0)GO TO 16
20600 READ(1,15)FUJ
20700 CALL DPYSET(3,LIST,500)
20800 CALL ALINE(306,300,476,300)
20900 CALL ALINE(306,215,306,385)
21000 CC CALL AIVECT(0,0)
21100 KY=FUJ(1)*85.0+300.
21200 CALL AIVECT(306,KY)
21300 DO 32 K=2,512,3
21400 KY2=FUJ(K)*85.0+300.
21500 CALL RVECT(1,KY2-KY)
21600 32 KY=KY2
21700 CALL DPYOUT(3)
21800 END
22000 SUBROUTINE DD
22100 COMMON/DRW/JDRW(2000)
23000 3 REWIND 21
23100 6 K=JDRW(1)+1
23200
23300 IF(K.LE.201)GO TO 5
23400 JDRW(1)=200
23500 K=201
23600 5 WRITE(21,120)K
23700 120 FORMAT(' 9999 1 ',I4,' 0 0 0 0 0 0 0 0')
23800 J=7
23900 L=8
24000 DO 12 K=1,JDRW(1),8
24100 IF(K+J.LT.JDRW(1))GO TO 12
24200 J=JDRW(1)-K
24300 L=J+1
24400 12 WRITE(21,11)L,(JDRW(N),N=K,K+J)
24500 CALL EXIT
24600 11 FORMAT(' 9999',I3,8I10)
24700 END